The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/ghostbbs.zip/BB1.PAS

Pascal/Delphi Source File | 1980-01-01 | 35KB | 1,199 lines

{$R-}
{$C-}
{$U-}
program GSBBS;
const
  version   = 'Version 2.14';

  applying = 'BBSINFO\APPLYING.TXT';
  welcome  = 'BBSINFO\WELCOME.TXT';   {Info files:    }
  otherBBS = 'BBSINFO\BBSLIST.TXT';
  helpfile = 'BBSINFO\BBSHELP.TXT';
  sysinfo  = 'BBSINFO\SYSINFO.TXT';
  meetings = 'BBSINFO\MEETING.TXT';
  bulletin = 'BBSINFO\BULLETIN.TXT';
  filehelp = 'BBSINFO\FILEHLP.TXT';
  mainmenu = 'BBSINFO\MAINMENU.TXT';
  readmenu = 'BBSINFO\READMENU.TXT';
  filemenu = 'BBSINFO\FILEMENU.TXT';
  editmenu = 'BBSINFO\EDITMENU.TXT';

  sysop   = 5;  { Access levels }
  prefuser= 4;
  expuser = 3;
  reg     = 2;
  newuser = 1;
  twit    = 0;

  noecho    = false;
  echo      = true;
  null      = #0;
  abort     = #3;
  bell      = #7;
  bksp      = #8;
  tab       = #9;
  lnfd      = #10;
  cls       = #12;
  cr        = #13;
  pause     = #19;
  esc       = #27;
  space     = ' ';
  maxnumsects  = 20; { maximun number of subboards }
  maxminon  = 60;  {max time in minutes user can be on}

type
  regpack = record
    case integer of
      1: (AX,BX,CX,DX,BP,DI,SI,DS,ES,Flags : Integer);
      2: (AL,AH,BL,BH,CL,CH,DL,DH          : Byte);
    end;

  str2      = string[2];
  name      = string[14];
  longname  = string[25];
  filbuffer = array[0..127] of byte;
  line      = string[80];
  person    = string[27];
  str10     = string[10];
  long      = string[150];

  {$I id.rec }   { id record descripter }

  log       = record                    { timelog.bbs record }
                who  : person;          { User name }
                rate : string[4];       { baud rate used}
                msgs : string[2];       { # of msgs posted }
                when : name;            { log in time }
                done : name;            { log off time }
              end;
  yesno     = array[boolean] of string[3];

const yn: yesno = ('NO','YES');

var
  real_name,
  address,
  town_city,
  state_zip   : longname;
  phone_number: name;
  downloads,
  uploads,
  messages_posted,
  logged_on   : integer;
  special_access : byte;
  init_logon : name;
  last_time_on : name;

  subboard:   byte;
  libfile:    file;
  libbuff:    filbuffer;
  libeof:     boolean;
  logfile:    file of log;
  logrec:     log;
  idfile:     file of sysid;
  idrec:      sysid;
  caller:     person;
  password,
  timeon,
  timeoff,
  cs,
  message:    name;
  buffer:     long;
  access:     byte;
  libsects,
  usernum,
  lastmess,
  nextmess,
  charcount,
  lastspace,
  bufpointer,
  width:      integer;
  umess:      line;
  upost:      boolean;
  nochat:     integer;
  controls,
  printon,
  local,
  filesopen,
  messopen,
  caps,
  expert:     boolean;
  exitchar, bl, lf, bs     : char;
  min,   onmin,   offmin   : byte;
  hour,  onhour,  offhour  : byte;
  date,  ondate,  offdate  : byte;
  month, onmonth, offmonth : byte;
  year                     : byte;
  usemin, usehour          : integer;
  last_message : array[1..maxnumsects] of integer;
  numsects, numfilesects : byte;
  good_signon: boolean;
  callnum : integer;
  chatsysop : boolean;
  color_mono : string[5];
  sysop_name : person;
  mail_sent, mail_rec, msg_nailed, msg_read : integer;
  today_date,today_year,today_month, today_timeon: byte;

{ beginning of buffered input routines }

const
intseg: INTEGER = 0; {filled with interrupt segment address}
parity_o   = 8;
parity_e   = 24;
parity_n   = 0;
databits_6 = 0;
databits_7 = 2;
databits_8 = 3;
stopbits_1 = 0;
stopbits_2 = 4;

save_buf_size = 4096;  {comport input buffer size do not change unless}
                       { you absolutely know what your doing          }
type
  bytepointer = ^byte;

VAR
baud,stopbits,databits        : INTEGER;
params, lorate, hirate        : BYTE;
parity                        : CHAR;
parity_                       : INTEGER;
base,comport                  : INTEGER;

{ interrupt vectors and pointers to them }

newvec,
oldvec     : bytepointer;
int4       : bytepointer ABSOLUTE $0000:$0030; {for COM1:}
int3       : bytepointer ABSOLUTE $0000:$002C; {for COM2:}
rcvbuf     : ARRAY[0..4095] OF BYTE;
inptr,
outptr     : INTEGER;
datardy    : boolean;

PROCEDURE init_comm_parms;
{ called to change comport parms }
BEGIN
    params := 0;
    lorate := LO(TRUNC(115200.0/baud));
    hirate := HI(TRUNC(115200.0/baud));

    CASE databits OF                 { Set the number of data bits. }
        6: databits := databits_6;
        7: databits := databits_7;
        8: databits := databits_8;
    END;

    CASE stopbits OF                 { Set the # of stop bits. }
        2: stopbits := stopbits_2;
        1: stopbits := stopbits_1;
    END;

    parity := UPCASE(parity);        { Convert parity code to upper case.  }
    CASE parity OF                   { Set the parity. }
        'O': parity_ := parity_o;
        'E': parity_ := parity_e;
        'N': parity_ := parity_n;
    END;
    params := databits + stopbits + parity_;
END;

FUNCTION inready:boolean;
{ determines if there is data at the keyboard or the serial port }
begin
  inready := datardy or keypressed;
end;

PROCEDURE setdtr;
BEGIN
    PORT[base+4] := $09; {DTR on and INT enabled}
END;

FUNCTION recvchar : char;
{ gets char from buffer }
BEGIN
  inline($FA);                        { suspend interrupts }
  if datardy then begin
    recvchar := chr(rcvbuf[outptr]);  { get char and advance buffer head }
    outptr := (outptr + 1) and $fff;
    if inptr = outptr then datardy := false;
  end;
  inline($FB);                        { resume interrupts }
END;

{following was pirated from a public domain comm program AND UPDATED for
  a 4k capture buffer }

PROCEDURE set_rs232_vector;
PROCEDURE int_handler1;
{ This routine buffers all incoming received data for com 1}
BEGIN
    INLINE(
    $50/             {PUSH AX}
    $52/             {PUSH DX}
    $57/             {PUSH DI}
    $1e/             {PUSH DS}          {save registers}
    $2e/             {CS:}
    $8e/$1e/intseg/  {MOV   DS,[Intseg]}        {get data segment pointer}
    $ba/$fd/$03/     {MOV   DX,$3FD}            {is character ready?}
    $ec/             {IN    AL,DX}
    $24/$01/         {AND   AL,01}
    $74/$1a/         {JZ    There:}             { no, skip entry}
                                                {note: used to be $74/$19/}
                                                {adjusted for 1 byte expansion}
                                                {in buffer size}
    $ba/$f8/$03/     {MOV   DX,$3F8}            { yes, get pointer}
    $a1/inptr/       {MOV   AX,[inptr]}         {get index TO buffer}
    $97/             {XCHG  DI,AX}
    $ec/             {IN    AL,DX}              {get data from receiver}
    $88/$85/rcvbuf/  {MOV   [DI+rcvbuf],AL}     {put data into buffer}
    $97/             {XCHG  DI,AX}              {increment pointer}
    $40/             {INC   AX}
    $25/$ff/$0f/     {AND   Ax,$fff}            {note: adjusted for a 4k buffer}
                                                {used to be $24/$ff/ and al,$ff}
    $a3/inptr/       {MOV   [inptr],AX}
    $b8/$01/$00/     {MOV   AX,1}               {show data is ready}
    $a2/datardy/     {MOV   [datardy],AX}
{There:}
    $b0/$20/         {MOV   AL,$20}             {eoi}
    $e6/$20/         {OUT   $20,AL}
    $1f/             {POP   DS}
    $5f/             {POP   DI}
    $5a/             {POP   DX}
    $58/             {POP   AX}
    $cf);            {IRET}

END;

PROCEDURE int_handler2;
{ This routine buffers all incoming received data for com2}
BEGIN
    INLINE(
    $50/             {PUSH AX}
    $52/             {PUSH DX}
    $57/             {PUSH DI}
    $1e/             {PUSH DS}          {save registers}
    $2e/             {CS:}
    $8e/$1e/intseg/  {MOV   DS,[Intseg]}        {get data segment pointer}
    $ba/$fd/$02/     {MOV   DX,$2FD}            {is character ready?}
    $ec/             {IN    AL,DX}
    $24/$01/         {AND   AL,01}
    $74/$1a/         {JZ    There:}             { no, skip entry}
                                                {note: used to be $74/$19/}
                                                {adjusted for 1 byte expansion}
                                                {in buffer size}
    $ba/$f8/$02/     {MOV   DX,$2F8}            { yes, get pointer}
    $a1/inptr/       {MOV   AX,[inptr]}         {get index TO buffer}
    $97/             {XCHG  DI,AX}
    $ec/             {IN    AL,DX}              {get data from receiver}
    $88/$85/rcvbuf/  {MOV   [DI+rcvbuf],AL}     {put data into buffer}
    $97/             {XCHG  DI,AX}              {increment pointer}
    $40/             {INC   AX}
    $25/$ff/$0f/     {AND   Ax,$fff}            {note: adjusted for a 4k buffer}
                                                {used to be $24/$ff/ and al,$ff}
    $a3/inptr/       {MOV   [inptr],AX}
    $b8/$01/$00/     {MOV   AX,1}               {show data is ready}
    $a2/datardy/     {MOV   [datardy],AX}
{There:}
    $b0/$20/         {MOV   AL,$20}             {eoi}
    $e6/$20/         {OUT   $20,AL}
    $1f/             {POP   DS}
    $5f/             {POP   DI}
    $5a/             {POP   DX}
    $58/             {POP   AX}
    $cf);            {IRET}

END;

BEGIN
    intseg := DSeg;

    case comport of
      1 : begin
            base   := $3f8;
            oldvec := int4;
            newvec := PTR(CSeg,Ofs(int_handler1)+7+5);
            int4 := newvec;
            INLINE(    $ba/$3f8/             {MOV  DX,BASE}
                       $ec/$ec/$ec/$ec/      {IN   AL,DX}
                       $ba/$3fd/$ec/         {MOV  DX,BASE+5 ! IN  AL,DX}
                       $ba/$3fe/$ec);        {MOV  DX,BASE+6 ! IN  AL,DX}
          end;
      2 : begin
            base   := $2f8;
            oldvec := int3;
            newvec := PTR(CSeg,Ofs(int_handler2)+7+5);
            int3 := newvec;
            INLINE(    $ba/$2f8/             {MOV  DX,BASE}
                       $ec/$ec/$ec/$ec/      {IN   AL,DX}
                       $ba/$2fd/$ec/         {MOV  DX,BASE+5 ! IN  AL,DX}
                       $ba/$2fe/$ec);        {MOV  DX,BASE+6 ! IN  AL,DX}
          end;
    end { case };

    datardy := FALSE;   inptr := 0;   outptr := inptr;

    case comport of
      1 : {port[$21] := port[$21] and $ef;} { enable interrupts for com1 }
           INLINE($e4/$21/$24/$ef/$e6/$21);
      2 : {port[$21] := port[$21] and $f7;} { enable interrupts for com2 }
           INLINE($e4/$21/$24/$f7/$e6/$21);
    end { case };
END;

PROCEDURE setup;
{sets up serial port}
VAR temp : BYTE;
BEGIN
    temp := PORT[base];
    temp := PORT[base+5];
    init_comm_parms;
    PORT[base+4] := $3;
    PORT[base+3] := (params OR hirate OR $80);
    Portw[base]  := TRUNC(115200.0/baud);
    PORT[base+3] := (params OR hirate) AND $7f;
    PORT[base+1] := $01;         {enable receiver interrupts}
    setdtr;                      {put station on-line}
END;

{end of buffered input routines }

procedure lineout(message: line); forward;

function outready: boolean;
{Returns true if serial output port is
 ready to transmit a new character}
  begin
    outready := ((port[base+5] and 32) > 0);
  end;

procedure xmitchar(ch: char);
{Transmits ch when serial output port is ready,
   unless we're in the local mode.}
  begin
    if not local then begin
      repeat until outready;
      port[base] := ord(ch);
    end;
  end;

function cts: boolean;
{This function returns true if a carrier tone is present on the modem
 and is frequently checked to see if the caller is still present.
 It always returns "true" in the local mode.}
  begin
    cts := ((port[base + 6] and 128) = 128) or local;
  end;


procedure clearmodem;        (* Modem Dependent *)
{Sets modem for auto-answer, CTS line as carrier detect, no command echo}
  var buffer: line;
      loop  : byte;
      ch    : char;
  begin
    buffer := 'ATS0=1 V0 Q1'; { <- put your initialization string here }
    for loop := 1 to length(buffer) do begin
      ch := buffer[loop];
      xmitchar(ch);
      delay(50);
    end;
    xmitchar(#13);
    writeln;
    write('Delaying...');
    delay(1000); {Delays while modem digests initialization codes}
    writeln;
  end;

function badframe: boolean;
{Indicates Framing Error - return false if not available.}
  begin
    badframe := (port[base + 5] and 8) = 8;
  end;

procedure dropRTS;
{ Lowers RS-232 RTS line - used to inhibit auto-answer
   and to cause modem to hang up }
  begin
    port[base + 4] := 8;
  end;

procedure raiseRTS;
(* Raises RTS line to enable auto-answer *)
  begin
    port[base + 4] := 11;
  end;

procedure setlocal;
{Sets local flag true and inhibits modem auto-answer}
  begin
    dropRTS; {Inhibits Rixon auto-answer}
    local := true;
  end;

procedure clearlocal;
{Clears local flag and allows modem auto-answer}
  begin
    raiseRTS;
    local := false;
  end;

procedure dispcaller;
{Displays caller's stats at bottom of host CRT;
 Replace with empty procedure if not desired.}
  begin
    textcolor(yellow);
    window(1,1,80,25);
    clrscr;
    gotoxy(1,1);
    writeln(caller,' #',callnum,' times=',logged_on,' Last=',idrec.lsto,' Start:',init_logon);
    write('Downlds=',downloads,' Uplds=',uploads,' Msgs=',messages_posted);
    write(' Password=',password,' Access=',access,' SpecA=',special_access);
    if chatsysop then textcolor(RED);
    write(' CHAT');
    window(1,3,80,25);
    gotoxy(1,1);
    textcolor(white);
  end;

procedure hangup;
{Signals modem to hang up - in this case by lowering RTS line for 500 msec.}
  begin
    if cts then lineout('--- Disconnected ---' + cr + lf);
    dropRTS;
    if local then clearlocal else repeat until not cts;
    raiseRTS;
  end;

procedure purgeline;
{gets rid of all chars in the reciver buffer }
var c : char;
  begin
  if not local then
    repeat
      if datardy then c:= recvchar;
    until not datardy;
  end;

procedure clock(var year,month,date,hour,min: byte);
{Returns with month in range 1(Jan)..12(Dec),
 date in 1..length of month, hour in 0..23 (24-hr clock)}
{ seconds are really not needed and i have chose to ignore them}
  procedure getdate;
  var
    allregs : regpack;
  begin
     allregs.ax := $2A * 256;
     MsDos(allregs);
     month := allregs.dx div 256;
     date := allregs.dx mod 256;
     year := allregs.cx - 1900;
  end;  {getdate}

  procedure gettime;
  var
   allregs : regpack;
  begin
     allregs.ax := $2C * 256;
     MsDos(allregs);
     hour := allregs.cx div 256;
     min := allregs.cx mod 256;
  end;  {gettime}

  begin
    getdate;
    gettime;
  end;

type monthname = string[3];
     monames  = array[1..12] of monthname;

const months: monames = ('Jan','Feb','Mar','Apr','May','Jun',
                         'Jul','Aug','Sep','Oct','Nov','Dec');

function time(year, month, date, hour, min: byte): name;
{Returns 14-character string containing time and date}
  var
    tempm,
    tempd,
    tempy,
    temph: string[2];
  begin
      str(min:2,tempm);
      str(hour:2,temph);
      str(date:2,tempd);
      str(year:2,tempy);
      if min < 10 then tempm := '0' + tempm[2];
      if date < 10 then tempd := '0' + tempd[2];
      if hour < 10 then temph := '0' + temph[2];
      if year < 10 then tempy := '0' + tempy[2];
      time := temph + ':' + tempm + ' ' + tempd + months[month] + tempy
  end;

procedure showtime;
  var
    message: name;
  begin
      clock(year, month, date, hour, min);
      message := time(year, month, date, hour, min);
      lineout('Time is: ' + message);
  end;

procedure calcconnect(var usehour, usemin: integer);
  begin
    clock(year, month, date, hour, min);
    usemin := 0;
    usehour := 0;
    usemin := 0;
    usemin := min - onmin + usemin;
    if usemin < 0 then begin
      usemin := usemin + 60;
      usehour := -1;
    end;
    usehour := hour - onhour + usehour;
    if usehour < 0 then usehour := usehour + 24;
  end;

procedure connecttime;
  var
    message: name;
  begin
      calcconnect(usehour, usemin);
      message := copy(time(1, 1, 1, usehour, usemin), 1, 5);
      lineout('Connect time: ' + message);
  end;

var
  cancelled,canstat : boolean;
  inbuffer  : line;

function charin(withecho: boolean):char; forward;

procedure sendout(ch: char);
{Character output - bypasses word-wrap; also performs
 "pause" and "abort" input character checks.}
  var temp: char;
      tctl: boolean;
  begin
    if not cancelled
      then begin
      if (inready and canstat)       {canstat=true is used to signal if the}
        then begin                   {output currently being performed can be}
        temp := charin(noecho);      {suspended or cancelled }
        if (temp = pause) then begin
          tctl := controls;
          controls := true;
          temp := charin(noecho);
          controls := tctl;
        end;
        if ((temp = abort) or (temp = space)) then cancelled := true;
      end; { if inready and canstat }
      if not (ch in [lnfd,null])
        then begin
          xmitchar(ch);
          if (ch = cr) then writeln
            else if (ch = bs)
                   then write(bksp)
                   else if ch <> bell then write(ch);
        end
        else if lf <> null then xmitchar(ch);
    end;
  end;

procedure flushbuff;
{ flushes the word wrap buffer }
  var
    outpointer: byte;
  begin
    if length(buffer) > lastspace then
      for outpointer := lastspace + 1 to length(buffer) do
        sendout(buffer[outpointer]);
    lastspace := length(buffer);
  end;

procedure resetbuff;
  begin
    bufpointer := 0;
    lastspace := 0;
    charcount := 0;
    buffer := '';
  end;

procedure charout(ch:char);
{Character output using word-wrap}
  var
    buffull   : boolean;
    temp      : long;
  begin
    if caps then ch := upcase(ch);
    if not (ch in [null..#31]) then charcount := succ(charcount);
    if (ch = bs) and (charcount > 0) then charcount := charcount - 1;
    buffer := buffer + ch;
    bufpointer := length(buffer);
    buffull := (charcount + 2 > width);
    if buffull then begin
      if (lastspace > 0)
        then begin
          buffer := copy(buffer, lastspace + 1, bufpointer - lastspace);
          charcount := length(buffer);
          lastspace := 0;
          end {then}
        else begin
          flushbuff;
          resetbuff;
        end; {else}
      sendout(cr);
      sendout(lf);
    end; {if}
    if ch in [null..space] then flushbuff;
    if (ch=cr) then resetbuff;
  end;

procedure stringout(message:line);
{outputs a string w/o cr & lf }
  var
    charpos: integer;
  begin
    for charpos := 1 to length(message) do charout(message[charpos]);
  end;

procedure lineout; (* "forward" declared in MACHDEP *)
{outputs a string with cr & lf }
  begin
    stringout(message);
    charout(cr);
    charout(lf);
  end;

function timedin: boolean;
{returns false if no character received in within
 one second: used for XMODEM and input timeout.}
  var times: integer;
  begin
    times := 0;
    while (times < 500) and not inready do begin
      times := times + 1;
      delay(2);
    end;
    timedin := inready and cts;
  end;

{ returns 256 + scan code (see appendix in turbo manual) }
FUNCTION get_key:INTEGER;
VAR
  r : regpack;
BEGIN
    r.ax:=0;
    Intr($16,r);
    IF LO(r.ax)=0
    THEN get_key:=HI(r.ax)+256
    ELSE get_key:=LO(r.ax);
END;

procedure talk; forward;
procedure savedefaults; forward;

function charin;
{gets input chars & masks & performs user timeout checks
 also checks for local function keys }
const
  f1 = 315;   { function key 1 = chat }
  f2 = 316;   { func. key 2 = sysoponly }
  f3 = 317;   { toggles nochat off }
  f4 = 318;   { toggles nochat on }
  f10 = 324;  { function key 10 = log user off }
  var
    ch: char;
    countime, got_key: integer;
  begin
    ch := null;
    countime := 0;
    repeat
      if timedin then ch := recvchar else countime := countime + 1;
      if keypressed
        then begin
          got_key := get_key;
          case got_key of
            f1  :  talk;     { chat }
            f2  :  begin
                     savedefaults;  {saves user stats so they can be edited}
                     if access < 2 then access :=2 else access := access + 1;
                     savedefaults;
                   end;
            f3  :  nochat := 1;
            f4  :  nochat := 2;
            f10 :  begin   { hang up on user }
                     dropRTS;
                     if local then clearlocal else repeat until not cts;
                     raiseRTS;
                   end;
            else if got_key < 256 then ch := chr(got_key)
          end; { case }
        end; { if keypressed }
      if countime > 300 then hangup;  { waits 5 min for input and hangs up if none recvd}
      if not cts then ch := cr;
      if (ch <> bs) and not controls then ch := chr(ord(ch) and 127);
    until (ch in [abort, pause, bs, tab, cr, space..#127])
           or (controls and (ch <> null));
    if (ch = #127) and not controls then ch := bs;
    if withecho
      then begin
        sendout(ch);
        if ch = bs then begin sendout(' '); sendout(bs); end;
      end;
    charin := ch;
  end;

function inputstring(withecho: boolean; maxchar: integer): line;
  var
    temp:    line;
    ch:      char;
  begin
    purgeline;
    temp := '';
    repeat
      ch := charin(noecho);
      if (ch = bs)
        then begin
          if length(temp) > 0
            then begin
              temp := copy(temp, 1, length(temp) - 1);
              if withecho
                then begin
                  sendout(bs);
                  sendout(space);
                  sendout(bs);
                end;
            end;
        end
        else begin  { if not a backspace }
          if maxchar = 1 then maxchar := 80;
          if (ch <> cr) and (length(temp) < maxchar)
              and ((ch in [tab, space..#126]) or controls)
            then begin
              if ch = tab    { handles tab char }
                then
                repeat
                  temp := temp + space;
                  if withecho then sendout(space);
                until (((length(temp) mod 8) = 0) or (length(temp) >= maxchar))
                else begin
                  temp := temp + ch;
                  if withecho then sendout(ch);
                end; {else}  { if tab}
            end
           else if ((ch <> cr) and (maxchar <> 1)) then sendout(bell);
        end;
    until (ch = cr);
    charout(cr); charout(lf);
    inputstring := temp;
  end;

function getinput(prompt:line; maxlength:integer; withecho:boolean):line;
  var posn: integer;
      temp: char;
  begin
    if cancelled then begin
      cancelled := false;
      lineout(space);
    end;
    if inbuffer = '' then begin
      repeat
        cancelled := false;
        stringout(prompt);
        if bl = bell then stringout(bl);
      until cancelled = false;
      inbuffer := inputstring(withecho,maxlength);
    end;
    if maxlength = 1 then begin
      if inbuffer = '' then temp := cr else begin
        temp := inbuffer[1];
        inbuffer := copy(inbuffer, 2, length(inbuffer)-1);
        if (length(inbuffer) > 1) and (inbuffer[1] = ';')
          then inbuffer := copy(inbuffer, 2, length(inbuffer)-1);
      end; {else}
      getinput := temp;
    end
    else begin
      posn := pos(';', inbuffer);
      if posn = 0 then posn := length(inbuffer) + 1;
      if posn > maxlength then begin
        posn := maxlength + 1;
        inbuffer := copy(inbuffer, 1, maxlength);
      end;
      getinput := copy(inbuffer, 1, posn - 1);
      if posn >= length(inbuffer)
        then inbuffer := ''
        else inbuffer := copy(inbuffer, posn + 1, length(inbuffer) - posn);
    end;
  end;

function allcaps(letters: line): line;
{ returns upper case string }
  var
    loop: byte;
    temp: person;
  begin
    temp := '';
    for loop := 1 to length(letters) do
      temp := temp + upcase(letters[loop]);
    allcaps := temp;
  end;

procedure userlog; forward;
procedure read_userlog; forward;

procedure awaitcall;
{ this procedure waits for the incoming call
  or escape = local signon
     f2     = print out timelog
     f3     = print out userlog.}
  const
    f2 = 316;
    f3 = 317;
  var
    junk: char;
    temp : byte;
    got_key : integer;
  begin
    baud := 1200;
    setup;
    write(cr + lf + 'Waiting for call...');
    purgeline;
    repeat
      if keypressed then begin
        got_key := get_key;
        local := got_key = 27;
        case got_key of
          f2 : begin  { if f2 then print out timelog to local terminal}
                 local := true;
                 temp := access;
                 access := sysop;
                 userlog;
                 local := false;
                 access := temp;
                 write(cr + lf + 'Waiting for call...');
               end;
          f3 : begin  { if ^l then printout userlog from local terminal}
                 local := true;
                 read_userlog;
                 local := false;
                 write(cr + lf + 'Waiting for call...');
               end;
        end; { case }
        if local then setlocal else exitchar := chr(got_key);
      end;
    until cts or (exitchar = abort);
    clrscr;
    if exitchar <> abort then begin
      if local then writeln('Local control.') else writeln('On line...');
      delay(500);
      purgeline;
      junk := charin(noecho);
      if badframe or (junk <> cr)
        then begin
          baud := 300;         { if badframe or CR not received then switch to 300}
          setup;
        end;
    end;
  end;

procedure clearsc;
  begin
    stringout(cs);  {clears local and remote terminals }
    clrscr;
    delay(500);   {allows time for slow terminal screen clears}
  end;

function getcap(prompt: line): char;
  begin
    getcap := upcase(getinput(prompt, 1, echo));
  end;

function getint(nmax, star: integer; prompt: line): integer;
{get and integer within a specified range}
  var temp, test: integer;
      outstr, userin: name;
  begin
    str(nmax:4, outstr);
    repeat
      temp := 0;
      userin := getinput(prompt, 4, echo);
      val(userin, temp, test);
      if (test = 0) and (temp > nmax) then lineout('Number too large: ' + outstr + ' maximum.');
    until ((test = 0) and (temp >= 0) and (temp <= nmax))
     or (userin = '*') or (userin = '') or (userin = '?') or not cts;
    if userin = '' then getint := 0
     else if userin = '?' then getint := -1
      else if userin = '*' then getint := star
       else getint := temp;
  end;


procedure textassign(filename: line; var result:integer);
begin
  assign(libfile,filename);
  {$I-} reset(libfile); {$I+}
  result := ioresult;
end;

procedure typefile(fname: line; nowrap: boolean);
{output a text file}
var in_ptr,
    result  : integer;
    in_buff : filbuffer;
    eofin   : boolean;
    c       : char;

procedure libread(var fileblock:filbuffer);
var ercode:integer;
begin
  {$I-} blockread(libfile,fileblock,1); {$I+}
  ercode := ioresult;
  eofin := (ercode <> 0);
end;

function getch:integer;
begin
  in_ptr := in_ptr + 1;
  if in_ptr > 127 then
    begin
      libread(in_buff);
      in_ptr := 0;
    end;
  getch := in_buff[in_ptr];
end;

  begin
    canstat := true;
    eofin := false;
    in_ptr := -1;
    textassign(fname, result);
    if result <> 0 then lineout('Cant find ' + fname + ' !')
    else begin
      libread(in_buff);
      while cts and not(cancelled or eofin) do
        begin
          c:=chr(getch);
          if c = #26 then eofin := true
            else begin
              if nowrap
                then begin
                      if (c <> lnfd) then charout(c);
                      if c = cr then charout(lf);
                end
                else sendout(c);
            end;
        end;
        close(libfile);
    end;
  canstat := false;
end;

procedure outfile(fname: line);
{output a text file with wordwrap}
  begin
    typefile(fname, true);
  end;

function itoa(x:integer):str10;
{ just a way of converting the str procedure into a more convenient function}
var temp : str10;
begin
   temp := '';
   str(x,temp);
   itoa := temp;
end;

function ftoa(x:real; places:integer):str10;
{ just a way of converting the str procedure into a more convenient function}
var temp : str10;
begin
   temp := '';
   str(x:places,temp);
   ftoa := temp;
end;

function nextuser: integer;
{ finds the next empty position in the IDS.BBS file }
  var temp: integer;
      found:boolean;
  begin
    temp := -1;
    found := false;
    assign(idfile,'IDS.BBS');
    reset(idfile);
    while ((found = false) and not eof(idfile)) do
      begin
        temp := temp + 1;
        read(idfile,idrec);
        if idrec.pass = '***' then found := true;
      end;
    if found = false then if filesize(idfile) > 0
                             then nextuser := filesize(idfile)
                             else nextuser := 0
                       else nextuser := temp;
  close(idfile);
  end;

procedure save_config;
{ setup file, more stuff could go in here, its up to you -
  right now just the total number of callers, the sysops name,
  and color or mono crt are defined externally here }
var callfile : text;
begin
  assign(callfile,'config.cnf');
  rewrite(callfile);
  writeln(callfile,callnum);
  writeln(callfile,sysop_name);
  writeln(callfile,color_mono);
  writeln(callfile,numsects);
  writeln(callfile,numfilesects);
  close(callfile);
end;

procedure get_config;
var callfile : text;
begin
  assign(callfile,'config.cnf');
  reset(callfile);
  readln(callfile,callnum);
  readln(callfile,sysop_name);
  readln(callfile,color_mono);
  readln(callfile,numsects);
  readln(callfile,numfilesects);
  close(callfile);
end;

Procedure update_userlog(updatestr:long);
{ used to update userlog. just call this proc with the string you
  want put into the userlog.bbs file }
var
  userlogfile : text;
  errcode : integer;

begin
  assign(userlogfile,'userlog.txt');
  {$I-}
  reset(userlogfile);
  {$I+}
  errcode := ioresult;
  if errcode <> 0 then close(userlogfile);
  if errcode = 0 then append(userlogfile)
                 else rewrite(userlogfile);
  writeln(userlogfile,updatestr);
  close(userlogfile);
end;

procedure read_userlog;
{reads the userlog.bbs file }
var ch : char;
    junk : file;
begin
  clearsc;
  outfile('userlog.txt');
  ch := getcap(' Kill (Y/N) ? ');
  if ch = 'Y' then
    begin
      assign(junk,'userlog.txt');
      {$I-}
      erase(junk);
      {$I+}
      if ioresult <> 0 then lineout('Already Been Erased! ');
    end;
end;

procedure savedefaults;
{ finish updating userlog.bbs and save the callers stats }
  var i : byte;
  begin
  update_userlog('Msgs Nailed : ' + itoa(msg_nailed) + cr + lf +
                 'Msgs Read   : ' + itoa(msg_read) + cr + lf +
                 'Mail Recvd  : ' + itoa(mail_rec) + cr + lf +
                 'Mail Sent   : ' + itoa(mail_sent));
  clock(year, month, date, hour, min);
  update_userlog('Time signed off : ' +  time(year, month, date, hour, min));
  calcconnect(usehour, usemin);
  update_userlog('Connect time : ' + copy(time(1, 1, 1, usehour, usemin), 1, 5));
    with idrec do begin
      save_config;
      logged_on := logged_on + 1;
      user := caller;
      if expert then exfl := 0 else exfl := 255;
      lsto := timeon;
      for i := 1 to numsects do
        lstm[i] := last_message[i];
      pass := password;
      user := caller;
      user2 := real_name;
      addr := address;
      city := town_city;
      szip := state_zip;
      phnn := phone_number;
      dld := downloads;
      uld := uploads;
      mptd := messages_posted;
      lgdn := logged_on;
      speca := special_access;
      intlg := init_logon;

      clock(year, month, date, hour, min);
      lsto := time(year, month, date, hour, min);
      tdt := date;
      tmo := month;
      tyr := year;
      tto := usemin + usehour * 60 + today_timeon;

      clr := cs;
      acc := access;
      bsp := bs;
      lnf := lf;
      upc := caps;
      wid := width;
    end;
    assign(idfile,'IDS.BBS');
    reset(idfile);
    seek(idfile, usernum);
    write(idfile, idrec);
    close(idfile);
  end;

procedure disconnect;
{ byby procedure }
  var
    ch: char;
  begin
    clearsc;
    ch := getcap('DEMATERIALIZE ? Are you SURE? (Y/N)? ');
    if ch = 'Y'
      then begin
        connecttime;
        lineout('You were caller number '+ itoa(callnum));
        lineout('Thanks for calling, ' + caller);
        hangup;
      end;
  end;

Procedure SetBorderColor(ColorNumber : byte);
{sets border color, i dont know if this works on an IBM mono screen
  so you can turn it off by putting 'MONO' in the CONFIG.BBS file }
Begin
if color_mono = 'COLOR'
  then begin
   Inline
      ($50/                 { PUSH AX             ; save registers         }
       $52/                 { PUSH DX             ;   "      "             }
       $8A/$86/ColorNumber/ { MOV  AL,[BP + ColorNumber]                   }
       $BA/$D9/$03/         { MOV  DX,03D9H       ; portaddress of 6845 CRT
                                                    color-select register  }
       $EE/                 { OUT  DX,AL          ; send the color code    }
       $5A/                 { POP  DX             ; restore registers      }
       $58)                 { POP  AX             ;   "         "          }
  end;
End;

{$I beep.inc }
{$I bb2.pas }
{$I bb3.pas }
{ Turbo Needs something here or you get an unexpected end of file error }